Usenet 1993 July/InfoMagic USENET CD-ROM July 1993.ISO/sources/unix/volume6/xlisp1.6/part4

Internet Message Format | 1986-11-30 | 43.0 KB

Subject:  v06i110:  Xlisp version 1.6 (xlisp1.6), Part04/06
Newsgroups: mod.sources
Approved: [e-mail]

Submitted by: seismo!utah-cs!b-davis (Brad Davis)
Mod.sources: Volume 6, Issue 110
Archive-name: xlisp1.6/Part04


#! /bin/sh
# This is a shell archive, meaning:
# 1. Remove everything above the #! /bin/sh line.
# 2. Save the resulting text in a file.
# 3. Execute the file with /bin/sh (not csh) to create the files:
#    Make.lattice
#    Makefile
#    asstuff.c
#    msstuff.c
#    pcfun.doc
#    pcstuff.c
#    psstuff.c
#    readme.1st
#    unixstuff.c
#    xlisp.h
# This archive created: Mon Jul 14 10:24:59 1986
export PATH; PATH=/bin:$PATH
if test -f 'Make.lattice'
then
    echo shar: will not over-write existing file "'Make.lattice'"
else
cat << \SHAR_EOF > 'Make.lattice'
# Because of braindamage in the Lattice runtime environment, where
# printf and friends are incapable of dealing with long strings, we
# must break up the list of files into managable pieces and join them
# in archives before linking.  Jeez...

SRC1 =    xlobj.c xllist.c xlcont.c xlbfun.c
SRC2 =    xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlio.c xlisp.c xljump.c
SRC2a =    xlmath.c xlprin.c xlread.c xlinit.c
SRC3 =    xlstr.c xlsubr.c xlsym.c xlsys.c xldbug.c asstuff.c
SRCS =    $(SRC1) $(SRC2) $(SRC2a) $(SRC3) xlisp.h

OBJS1 =    xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o
OBJS2 =    xlftab.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o
OBJS3 =    xlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o asstuff.o
OBJS =    lib1.o lib2.o lib3.o

MISC1 =    Makefile fact.lsp init.lsp object.lsp prolog.lsp trace.lsp
MISC2 =    xlstub.c.NOTUSED
MISC  =    $(MISC1) $(MISC2)

CFLAGS =    -O
CC  =        cc
#LIBS =        -lm

xlisp :        $(OBJS)
        $(CC) -o xlisp $(CFLAGS) $(OBJS) $(LIBS)

lib1.o :    $(OBJS1)
        join $(OBJS1) as lib1.o

lib2.o :    $(OBJS2)
        join $(OBJS2) as lib2.o

lib3.o :    $(OBJS3)
        join $(OBJS3) as lib3.o

clean :
        delete $(OBJS)
        delete $(OBJS1)
        delete $(OBJS2)
        delete $(OBJS3)


xlbfun.o :    xlbfun.c xlisp.h
        $(CC) -c $(CFLAGS) xlbfun.c

xlcont.o :    xlcont.c xlisp.h
        $(CC) -c $(CFLAGS) xlcont.c

xldbug.o :    xldbug.c xlisp.h
        $(CC) -c $(CFLAGS) xldbug.c

xldmem.o :    xldmem.c xlisp.h
        $(CC) -c $(CFLAGS) xldmem.c

xleval.o :    xleval.c xlisp.h
        $(CC) -c $(CFLAGS) xleval.c

xlfio.o :    xlfio.c xlisp.h
        $(CC) -c $(CFLAGS) xlfio.c

xlftab.o :    xlftab.c xlisp.h
        $(CC) -c $(CFLAGS) xlftab.c

xlglob.o :    xlglob.c xlisp.h
        $(CC) -c $(CFLAGS) xlglob.c

xlinit.o :    xlinit.c xlisp.h
        $(CC) -c $(CFLAGS) xlinit.c

xlio.o :    xlio.c xlisp.h
        $(CC) -c $(CFLAGS) xlio.c

xlisp.o :    xlisp.c xlisp.h
        $(CC) -c $(CFLAGS) xlisp.c

xljump.o :    xljump.c xlisp.h
        $(CC) -c $(CFLAGS) xljump.c

xllist.o :    xllist.c xlisp.h
        $(CC) -c $(CFLAGS) xllist.c

xlmath.o :    xlmath.c xlisp.h
        $(CC) -c $(CFLAGS) xlmath.c

xlobj.o :    xlobj.c xlisp.h
        $(CC) -c $(CFLAGS) xlobj.c

xlprin.o :    xlprin.c xlisp.h
        $(CC) -c $(CFLAGS) xlprin.c

xlread.o :    xlread.c xlisp.h
        $(CC) -c $(CFLAGS) xlread.c

xlstr.o :    xlstr.c xlisp.h
        $(CC) -c $(CFLAGS) xlstr.c

xlstub.o :    xlstub.c xlisp.h
        $(CC) -c $(CFLAGS) xlstub.c

xlsubr.o :    xlsubr.c xlisp.h
        $(CC) -c $(CFLAGS) xlsubr.c

xlsym.o :    xlsym.c xlisp.h
        $(CC) -c $(CFLAGS) xlsym.c

xlsys.o :    xlsys.c xlisp.h
        $(CC) -c $(CFLAGS) xlsys.c

asstuff.o :    asstuff.c
        $(CC) -c $(CFLAGS) asstuff.c
SHAR_EOF
fi # end of overwriting check
if test -f 'Makefile'
then
    echo shar: will not over-write existing file "'Makefile'"
else
cat << \SHAR_EOF > 'Makefile'
OS=unix

SRC1 =    xlobj.c xllist.c xlcont.c xlbfun.c
SRC2 =    xldmem.c xleval.c xlfio.c xlftab.c xlglob.c xlio.c xlisp.c xljump.c
SRC2a =    xlmath.c xlprin.c xlread.c xlinit.c
SRC3 =    xlstr.c xlsubr.c xlsym.c xlsys.c xldbug.c $(OS)stuff.c
SRCS =    $(SRC1) $(SRC2) $(SRC2a) $(SRC3) xlisp.h

OBJS1 =    xlbfun.o xlcont.o xldbug.o xldmem.o xleval.o xlfio.o
OBJS2 =    xlftab.o xlglob.o xlinit.o xlio.o xlisp.o xljump.o xllist.o xlmath.o
OBJS3 =    xlobj.o xlprin.o xlread.o xlstr.o xlsubr.o xlsym.o xlsys.o $(OS)stuff.o
OBJS =    $(OBJS1) $(OBJS2) $(OBJS3)

MISC1 =    Makefile fact.lsp init.lsp object.lsp prolog.lsp trace.lsp
MISC2 =    xlstub.c.NOTUSED
MISC  =    $(MISC1) $(MISC2)

CFLAGS =    -O
CC  =        cc
LIBS =        -lm

xlisp : $(OBJS)
    cc -o xlisp.unix $(CFLAGS) $(OBJS) $(LIBS)

rcs : $(SRCS)
    rcs -l $?
    touch rcs

lint :
    lint -ach $(SRCS)

new : clean
    rm -f xlisp
    make xlisp

clean :
    rm -f *.o

shar : $(SRCS) $(MISC)
    shar -c -v xlisp.doc > xlisp1.shar
    shar -c -v $(SRC1) > xlisp2.shar
    shar -c -v $(SRC2) > xlisp3.shar
    shar -c -v $(SRC3) $(MISC) > xlisp4.shar


xlbfun.o :    xlbfun.c xlisp.h
        $(CC) -c $(CFLAGS) xlbfun.c

xlcont.o :    xlcont.c xlisp.h
        $(CC) -c $(CFLAGS) xlcont.c

xldbug.o :    xldbug.c xlisp.h
        $(CC) -c $(CFLAGS) xldbug.c

xldmem.o :    xldmem.c xlisp.h
        $(CC) -c $(CFLAGS) xldmem.c

xleval.o :    xleval.c xlisp.h
        $(CC) -c $(CFLAGS) xleval.c

xlfio.o :    xlfio.c xlisp.h
        $(CC) -c $(CFLAGS) xlfio.c

xlftab.o :    xlftab.c xlisp.h
        $(CC) -c $(CFLAGS) xlftab.c

xlglob.o :    xlglob.c xlisp.h
        $(CC) -c $(CFLAGS) xlglob.c

xlinit.o :    xlinit.c xlisp.h
        $(CC) -c $(CFLAGS) xlinit.c

xlio.o :    xlio.c xlisp.h
        $(CC) -c $(CFLAGS) xlio.c

xlisp.o :    xlisp.c xlisp.h
        $(CC) -c $(CFLAGS) xlisp.c

xljump.o :    xljump.c xlisp.h
        $(CC) -c $(CFLAGS) xljump.c

xllist.o :    xllist.c xlisp.h
        $(CC) -c $(CFLAGS) xllist.c

xlmath.o :    xlmath.c xlisp.h
        $(CC) -c $(CFLAGS) xlmath.c

xlobj.o :    xlobj.c xlisp.h
        $(CC) -c $(CFLAGS) xlobj.c

xlprin.o :    xlprin.c xlisp.h
        $(CC) -c $(CFLAGS) xlprin.c

xlread.o :    xlread.c xlisp.h
        $(CC) -c $(CFLAGS) xlread.c

xlstr.o :    xlstr.c xlisp.h
        $(CC) -c $(CFLAGS) xlstr.c

xlstub.o :    xlstub.c xlisp.h
        $(CC) -c $(CFLAGS) xlstub.c

xlsubr.o :    xlsubr.c xlisp.h
        $(CC) -c $(CFLAGS) xlsubr.c

xlsym.o :    xlsym.c xlisp.h
        $(CC) -c $(CFLAGS) xlsym.c

xlsys.o :    xlsys.c xlisp.h
        $(CC) -c $(CFLAGS) xlsys.c

$(OS)stuff.o :    $(OS)stuff.c
        $(CC) -c $(CFLAGS) $(OS)stuff.c
SHAR_EOF
fi # end of overwriting check
if test -f 'asstuff.c'
then
    echo shar: will not over-write existing file "'asstuff.c'"
else
cat << \SHAR_EOF > 'asstuff.c'
/* asstuff.c - Amiga specific routines */

#include "xlisp.h"

#ifndef MANX
#define agetc getc    /* Not sure if this will work in all cases (fnf) */
#define aputc putc    /* Not sure if this will work in all cases (fnf) */
#endif

#define LBSIZE 200

/* external routines */
extern double ran();

/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;

/* line buffer variables */
static char lbuf[LBSIZE];
static int  lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;

#define NEW 1006
static long xlispwindow;

/* osinit - initialize */
osinit(banner)
  char *banner;
{
    extern int Enable_Abort;

    Enable_Abort = 0;        /* Turn off ^C interrupt in case it's on */
    xlispwindow = Open("RAW:1/1/639/199/Xlisp by David Betz", NEW);
    while (*banner != '\000') {
    xputc (*banner++);
    }
    xputc ('\n');
    lposition = 0;
    lindex = 0;
    lcount = 0;
}

osfinish ()
{
    Close (xlispwindow);
}

/* osrand - return a random number between 0 and n-1 */
int osrand(n)
  int n;
{
    n = (int)(ran() * (double)n);
    return (n < 0 ? -n : n);
}

/* osgetc - get a character from the terminal */
int osgetc(fp)
  FILE *fp;
{
    int ch;

    /* check for input from a file other than stdin */
    if (fp != stdin)
    return ((int)agetc(fp));

    /* check for a buffered character */
    if (lcount--)
    return ((int)lbuf[lindex++]);

    /* get an input line */
    for (lcount = 0; ; )
    switch (ch = xgetc()) {
    case '\n':
    case '\r':
        lbuf[lcount++] = '\n';
        xputc('\r'); xputc('\n'); lposition = 0;
        lindex = 0; lcount--;
        return ((int)lbuf[lindex++]);
    case '\010':
    case '\177':
        if (lcount) {
            lcount--;
            while (lposition > lpos[lcount]) {
            xputc('\010'); xputc(' '); xputc('\010');
            lposition--;
            }
        }
        break;
    case '\032':
        osflush();
        return (EOF);
    default:
        if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
            lbuf[lcount] = ch;
            lpos[lcount] = lposition;
            if (ch == '\t')
            do {
                xputc(' ');
            } while (++lposition & 7);
            else {
            xputc(ch); lposition++;
            }
            lcount++;
        }
        else {
            osflush();
            switch (ch) {
            case '\003':    xltoplevel();    /* control-c */
            case '\007':    xlcleanup();    /* control-g */
            case '\020':    xlcontinue();    /* control-p */
            case '\032':    return (EOF);    /* control-z */
            default:        return (ch);
            }
        }
    }
}

/* osputc - put a character to the terminal */
osputc(ch,fp)
  int ch; FILE *fp;
{
    /* check for output to something other than stdout */
    if (fp != stdout)
    return (aputc(ch,fp));

    /* check for control characters */
    oscheck();

    /* output the character */
    if (ch == '\n') {
    xputc('\r'); xputc('\n');
    lposition = 0;
    }
    else {
    xputc(ch);
    lposition++;
   }
}

/* oscheck - check for control characters during execution */
oscheck()
{
    int ch;
    if (ch = xcheck())
    switch (ch) {
    case '\002':    osflush(); xlbreak("BREAK",s_unbound); break;
    case '\003':    osflush(); xltoplevel(); break;
    }
}

/* osflush - flush the input line buffer */
osflush()
{
    lindex = lcount = 0;
    osputc('\n',stdout);
    prompt = 1;
}

/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
    char ch;

    Read (xlispwindow, &ch, 1);
    return (ch & 0xFF);
}

/* xputc - put a character to the terminal */
static xputc(ch)
  int ch;
{
    char chout;

    chout = ch;
    Write (xlispwindow, &chout, 1L);
}

/* xcheck - check for a character */
static int xcheck()
{
    if (WaitForChar (xlispwindow, 0L) == 0L)
    return (0);
    return (xgetc() & 0xFF);
}

/* xdos - execute a dos command */
NODE *xdos(args)
  NODE *args;
{
    char *cmd;
    cmd = xlmatch(STR,&args)->n_str;
    xllastarg(args);
    return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}

int system (cmd)
char *cmd;
{
    return (Execute(cmd, 0L, xlispwindow));
}

double ran ()    /* Just punt for now, not in Manx C; FIXME!!*/
{
    static long seed = 654321;
    long lval;
    double dval;

    seed *= ((8 * (123456) - 3));
    lval = seed & 0xFFFF;
    dval = ((double) lval) / ((double) (0x10000));
    return (dval);
}

/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
  NODE *args;
{
    xllastarg(args);
    return (cvfixnum((FIXNUM)xgetc()));
}

#ifdef DEADCODE    /* Dont' use this for now?  (fnf) */

/* xcursor - set the cursor position */
NODE *xcursor(args)
  NODE *args;
{
    int row,col;
    row = xlmatch(INT,&args)->n_int;
    col = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    scr_curs(row,col);
    return (NIL);
}

/* xclear - clear the screen */
NODE *xclear(args)
  NODE *args;
{
    xllastarg(args);
    scr_clear();
    return (NIL);
}

/* xeol - clear to end of line */
NODE *xeol(args)
  NODE *args;
{
    xllastarg(args);
    scr_eol();
    return (NIL);
}


/* xeos - clear to end of screen */
NODE *xeos(args)
  NODE *args;
{
    xllastarg(args);
    scr_eos();
    return (NIL);
}

/* xlinsert - insert line */
NODE *xlinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_linsert();
    return (NIL);
}

/* xldelete - delete line */
NODE *xldelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_ldelete();
    return (NIL);
}

/* xcinsert - insert character */
NODE *xcinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_cinsert();
    return (NIL);
}

/* xcdelete - delete character */
NODE *xcdelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_cdelete();
    return (NIL);
}

/* xinverse - set/clear inverse video */
NODE *xinverse(args)
  NODE *args;
{
    NODE *val;
    val = xlarg(&args);
    xllastarg(args);
    scr_invers(val ? 1 : 0);
    return (NIL);
}

/* xline - draw a line */
NODE *xline(args)
  NODE *args;
{
    int x1,y1,x2,y2;
    x1 = xlmatch(INT,&args)->n_int;
    y1 = xlmatch(INT,&args)->n_int;
    x2 = xlmatch(INT,&args)->n_int;
    y2 = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    line(x1,y1,x2,y2);
    return (NIL);
}

/* xpoint - draw a point */
NODE *xpoint(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    point(x,y);
    return (NIL);
}

/* xcircle - draw a circle */
NODE *xcircle(args)
  NODE *args;
{
    int x,y,r;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    r = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    circle(x,y,r);
    return (NIL);
}

/* xaspect - set the aspect ratio */
NODE *xaspect(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    set_asp(x,y);
    return (NIL);
}

/* xcolors - setup the display colors */
NODE *xcolors(args)
  NODE *args;
{
    int c,p,b;
    c = xlmatch(INT,&args)->n_int;
    p = xlmatch(INT,&args)->n_int;
    b = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    color(c);
    palette(p);
    ground(b);
    return (NIL);
}

/* xmode - set the display mode */
NODE *xmode(args)
  NODE *args;
{
    int m;
    m = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    mode(m);
    return (NIL);
}

#endif DEADCODE

/* osfinit - initialize pc specific functions */
osfinit()
{
    xlsubr("DOS",        SUBR,    xdos);
    xlsubr("GET-KEY",        SUBR,    xgetkey);
#ifdef DEADCODE
    xlsubr("SET-CURSOR",    SUBR,    xcursor);
    xlsubr("CLEAR",        SUBR,    xclear);
    xlsubr("CLEAR-EOL",        SUBR,    xeol);
    xlsubr("CLEAR-EOS",        SUBR,    xeos);
    xlsubr("INSERT-LINE",    SUBR,    xlinsert);
    xlsubr("DELETE-LINE",    SUBR,    xldelete);
    xlsubr("INSERT-CHAR",    SUBR,    xcinsert);
    xlsubr("DELETE-CHAR",    SUBR,    xcdelete);
    xlsubr("SET-INVERSE",    SUBR,    xinverse);
    xlsubr("LINE",         SUBR,    xline);
    xlsubr("POINT",        SUBR,    xpoint);
    xlsubr("CIRCLE",        SUBR,    xcircle);
    xlsubr("ASPECT-RATIO",    SUBR,    xaspect);
    xlsubr("COLORS",        SUBR,    xcolors);
    xlsubr("MODE",         SUBR,    xmode);
#endif DEADCODE
}


SHAR_EOF
fi # end of overwriting check
if test -f 'msstuff.c'
then
    echo shar: will not over-write existing file "'msstuff.c'"
else
cat << \SHAR_EOF > 'msstuff.c'
/* msstuff.c - ms-dos specific routines */

#include "xlisp.h"

#define LBSIZE 200

/* external routines */
extern double ran();

/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;

/* line buffer variables */
static char lbuf[LBSIZE];
static int  lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;

/* osinit - initialize */
osinit(banner)
  char *banner;
{
    printf("%s\n",banner);
    lposition = 0;
    lindex = 0;
    lcount = 0;
}

/* osrand - return a random number between 0 and n-1 */
int osrand(n)
  int n;
{
    n = (int)(ran() * (double)n);
    return (n < 0 ? -n : n);
}

/* osgetc - get a character from the terminal */
int osgetc(fp)
  FILE *fp;
{
    int ch;

    /* check for input from a file other than stdin */
    if (fp != stdin)
    return (agetc(fp));

    /* check for a buffered character */
    if (lcount--)
    return (lbuf[lindex++]);

    /* get an input line */
    for (lcount = 0; ; )
    switch (ch = xgetc()) {
    case '\r':
        lbuf[lcount++] = '\n';
        xputc('\r'); xputc('\n'); lposition = 0;
        lindex = 0; lcount--;
        return (lbuf[lindex++]);
    case '\010':
    case '\177':
        if (lcount) {
            lcount--;
            while (lposition > lpos[lcount]) {
            xputc('\010'); xputc(' '); xputc('\010');
            lposition--;
            }
        }
        break;
    case '\032':
        osflush();
        return (EOF);
    default:
        if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
            lbuf[lcount] = ch;
            lpos[lcount] = lposition;
            if (ch == '\t')
            do {
                xputc(' ');
            } while (++lposition & 7);
            else {
            xputc(ch); lposition++;
            }
            lcount++;
        }
        else {
            osflush();
            switch (ch) {
            case '\003':    xltoplevel();    /* control-c */
            case '\007':    xlcleanup();    /* control-g */
            case '\020':    xlcontinue();    /* control-p */
            case '\032':    return (EOF);    /* control-z */
            default:        return (ch);
            }
        }
    }
}

/* osputc - put a character to the terminal */
osputc(ch,fp)
  int ch; FILE *fp;
{
    /* check for output to something other than stdout */
    if (fp != stdout)
    return (aputc(ch,fp));

    /* check for control characters */
    oscheck();

    /* output the character */
    if (ch == '\n') {
    xputc('\r'); xputc('\n');
    lposition = 0;
    }
    else {
    xputc(ch);
    lposition++;
   }
}

/* oscheck - check for control characters during execution */
oscheck()
{
    int ch;
    if (ch = xcheck())
    switch (ch) {
    case '\002':    osflush(); xlbreak("BREAK",s_unbound); break;
    case '\003':    osflush(); xltoplevel(); break;
    }
}

/* osflush - flush the input line buffer */
osflush()
{
    lindex = lcount = 0;
    osputc('\n',stdout);
    prompt = 1;
}

/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
    return (bdos(7));
}

/* xputc - put a character to the terminal */
static xputc(ch)
  int ch;
{
    bdos(6,ch);
}

/* xcheck - check for a character */
static int xcheck()
{
    return (bdos(6,0xFF));
}

/* xdos - execute a dos command */
NODE *xdos(args)
  NODE *args;
{
    char *cmd;
    cmd = xlmatch(STR,&args)->n_str;
    xllastarg(args);
    return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}

/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
  NODE *args;
{
    xllastarg(args);
    return (cvfixnum((FIXNUM)xgetc()));
}

/* osfinit - initialize pc specific functions */
osfinit()
{
    xlsubr("DOS",        SUBR,    xdos);
    xlsubr("GET-KEY",        SUBR,    xgetkey);
}

SHAR_EOF
fi # end of overwriting check
if test -f 'pcfun.doc'
then
    echo shar: will not over-write existing file "'pcfun.doc'"
else
cat << \SHAR_EOF > 'pcfun.doc'
PCFUN.MEM
12/9/85

This is a list of IBM-PC specific functions in XLISP version 1.5d.
All of the functions take integers as arguments except where noted.
All of the functions return NIL.

(dos <cmd>)  Execute a DOS command
  <cmd>    the command string

(get-key)  Get a key from the keyboard

(set-cursor <row> <col>)  Set the cursor position

(clear)  Clear the screen

(clear-eol)  Clear to the end of the current line

(clear-eos)  Clear to the end of the screen

(insert-line)  Insert a line

(delete-line)  Delete a line

(insert-char)  Insert a character

(delete-char)  Delete a character

(set-inverse <mode>)  Set inverse mode
   <mode> is T for inverse, NIL for normal

(line <x1> <y1> <x2> <y2>)  Draw a line

(point <x> <y>)  Draw a point

(circle <x> <y> <radius>)  Draw a circle

(aspect-ratio <x> <y>)  Set the aspect ratio for circles

(colors <color> <palette> <background>)  Set the display colors

(mode <mode>)  Set the display mode


SHAR_EOF
fi # end of overwriting check
if test -f 'pcstuff.c'
then
    echo shar: will not over-write existing file "'pcstuff.c'"
else
cat << \SHAR_EOF > 'pcstuff.c'
/* pcstuff.c - ibm-pc specific routines */

#include "xlisp.h"

#define LBSIZE 200

/* external routines */
extern double ran();

/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;

/* line buffer variables */
static char lbuf[LBSIZE];
static int  lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;

/* osinit - initialize */
osinit(banner)
  char *banner;
{
    printf("%s\n",banner);
    lposition = 0;
    lindex = 0;
    lcount = 0;
}

/* osrand - return a random number between 0 and n-1 */
int osrand(n)
  int n;
{
    n = (int)(ran() * (double)n);
    return (n < 0 ? -n : n);
}

/* osgetc - get a character from the terminal */
int osgetc(fp)
  FILE *fp;
{
    int ch;

    /* check for input from a file other than stdin */
    if (fp != stdin)
    return (agetc(fp));

    /* check for a buffered character */
    if (lcount--)
    return (lbuf[lindex++]);

    /* get an input line */
    for (lcount = 0; ; )
    switch (ch = xgetc()) {
    case '\r':
        lbuf[lcount++] = '\n';
        xputc('\r'); xputc('\n'); lposition = 0;
        lindex = 0; lcount--;
        return (lbuf[lindex++]);
    case '\010':
    case '\177':
        if (lcount) {
            lcount--;
            while (lposition > lpos[lcount]) {
            xputc('\010'); xputc(' '); xputc('\010');
            lposition--;
            }
        }
        break;
    case '\032':
        osflush();
        return (EOF);
    default:
        if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
            lbuf[lcount] = ch;
            lpos[lcount] = lposition;
            if (ch == '\t')
            do {
                xputc(' ');
            } while (++lposition & 7);
            else {
            xputc(ch); lposition++;
            }
            lcount++;
        }
        else {
            osflush();
            switch (ch) {
            case '\003':    xltoplevel();    /* control-c */
            case '\007':    xlcleanup();    /* control-g */
            case '\020':    xlcontinue();    /* control-p */
            case '\032':    return (EOF);    /* control-z */
            default:        return (ch);
            }
        }
    }
}

/* osputc - put a character to the terminal */
osputc(ch,fp)
  int ch; FILE *fp;
{
    /* check for output to something other than stdout */
    if (fp != stdout)
    return (aputc(ch,fp));

    /* check for control characters */
    oscheck();

    /* output the character */
    if (ch == '\n') {
    xputc('\r'); xputc('\n');
    lposition = 0;
    }
    else {
    xputc(ch);
    lposition++;
   }
}

/* oscheck - check for control characters during execution */
oscheck()
{
    int ch;
    if (ch = xcheck())
    switch (ch) {
    case '\002':    osflush(); xlbreak("BREAK",s_unbound); break;
    case '\003':    osflush(); xltoplevel(); break;
    }
}

/* osflush - flush the input line buffer */
osflush()
{
    lindex = lcount = 0;
    osputc('\n',stdout);
    prompt = 1;
}

/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
    return (scr_getc() & 0xFF);
}

/* xputc - put a character to the terminal */
static xputc(ch)
  int ch;
{
    scr_putc(ch);
}

/* xcheck - check for a character */
static int xcheck()
{
    if (scr_poll() == -1)
    return (0);
    return (scr_getc() & 0xFF);
}

/* xdos - execute a dos command */
NODE *xdos(args)
  NODE *args;
{
    char *cmd;
    cmd = xlmatch(STR,&args)->n_str;
    xllastarg(args);
    return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}

/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
  NODE *args;
{
    xllastarg(args);
    return (cvfixnum((FIXNUM)scr_getc()));
}

/* xcursor - set the cursor position */
NODE *xcursor(args)
  NODE *args;
{
    int row,col;
    row = xlmatch(INT,&args)->n_int;
    col = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    scr_curs(row,col);
    return (NIL);
}

/* xclear - clear the screen */
NODE *xclear(args)
  NODE *args;
{
    xllastarg(args);
    scr_clear();
    return (NIL);
}

/* xeol - clear to end of line */
NODE *xeol(args)
  NODE *args;
{
    xllastarg(args);
    scr_eol();
    return (NIL);
}


/* xeos - clear to end of screen */
NODE *xeos(args)
  NODE *args;
{
    xllastarg(args);
    scr_eos();
    return (NIL);
}

/* xlinsert - insert line */
NODE *xlinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_linsert();
    return (NIL);
}

/* xldelete - delete line */
NODE *xldelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_ldelete();
    return (NIL);
}

/* xcinsert - insert character */
NODE *xcinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_cinsert();
    return (NIL);
}

/* xcdelete - delete character */
NODE *xcdelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_cdelete();
    return (NIL);
}

/* xinverse - set/clear inverse video */
NODE *xinverse(args)
  NODE *args;
{
    NODE *val;
    val = xlarg(&args);
    xllastarg(args);
    scr_invers(val ? 1 : 0);
    return (NIL);
}

/* xline - draw a line */
NODE *xline(args)
  NODE *args;
{
    int x1,y1,x2,y2;
    x1 = xlmatch(INT,&args)->n_int;
    y1 = xlmatch(INT,&args)->n_int;
    x2 = xlmatch(INT,&args)->n_int;
    y2 = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    line(x1,y1,x2,y2);
    return (NIL);
}

/* xpoint - draw a point */
NODE *xpoint(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    point(x,y);
    return (NIL);
}

/* xcircle - draw a circle */
NODE *xcircle(args)
  NODE *args;
{
    int x,y,r;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    r = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    circle(x,y,r);
    return (NIL);
}

/* xaspect - set the aspect ratio */
NODE *xaspect(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    set_asp(x,y);
    return (NIL);
}

/* xcolors - setup the display colors */
NODE *xcolors(args)
  NODE *args;
{
    int c,p,b;
    c = xlmatch(INT,&args)->n_int;
    p = xlmatch(INT,&args)->n_int;
    b = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    color(c);
    palette(p);
    ground(b);
    return (NIL);
}

/* xmode - set the display mode */
NODE *xmode(args)
  NODE *args;
{
    int m;
    m = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    mode(m);
    return (NIL);
}

/* osfinit - initialize pc specific functions */
osfinit()
{
    xlsubr("DOS",        SUBR,    xdos);
    xlsubr("GET-KEY",        SUBR,    xgetkey);
    xlsubr("SET-CURSOR",    SUBR,    xcursor);
    xlsubr("CLEAR",        SUBR,    xclear);
    xlsubr("CLEAR-EOL",        SUBR,    xeol);
    xlsubr("CLEAR-EOS",        SUBR,    xeos);
    xlsubr("INSERT-LINE",    SUBR,    xlinsert);
    xlsubr("DELETE-LINE",    SUBR,    xldelete);
    xlsubr("INSERT-CHAR",    SUBR,    xcinsert);
    xlsubr("DELETE-CHAR",    SUBR,    xcdelete);
    xlsubr("SET-INVERSE",    SUBR,    xinverse);
    xlsubr("LINE",         SUBR,    xline);
    xlsubr("POINT",        SUBR,    xpoint);
    xlsubr("CIRCLE",        SUBR,    xcircle);
    xlsubr("ASPECT-RATIO",    SUBR,    xaspect);
    xlsubr("COLORS",        SUBR,    xcolors);
    xlsubr("MODE",         SUBR,    xmode);
}

SHAR_EOF
fi # end of overwriting check
if test -f 'psstuff.c'
then
    echo shar: will not over-write existing file "'psstuff.c'"
else
cat << \SHAR_EOF > 'psstuff.c'
/* pcstuff.c - ibm-pc specific routines */

#include "xlisp.h"

#define LBSIZE 200

/* external routines */
extern double ran();

/* external variables */
extern NODE *s_unbound,*true;
extern int prompt;
extern int errno;

/* line buffer variables */
static char lbuf[LBSIZE];
static int  lpos[LBSIZE];
static int lindex;
static int lcount;
static int lposition;

/* osinit - initialize */
osinit(banner)
  char *banner;
{
    printf("%s\n",banner);
    lposition = 0;
    lindex = 0;
    lcount = 0;
}

/* osrand - return a random number between 0 and n-1 */
int osrand(n)
  int n;
{
    n = (int)(ran() * (double)n);
    return (n < 0 ? -n : n);
}

/* osgetc - get a character from the terminal */
int osgetc(fp)
  FILE *fp;
{
    int ch;

    /* check for input from a file other than stdin */
    if (fp != stdin)
    return (agetc(fp));

    /* check for a buffered character */
    if (lcount--)
    return (lbuf[lindex++]);

    /* get an input line */
    for (lcount = 0; ; )
    switch (ch = xgetc()) {
    case '\r':
        lbuf[lcount++] = '\n';
        xputc('\r'); xputc('\n'); lposition = 0;
        lindex = 0; lcount--;
        return (lbuf[lindex++]);
    case '\010':
    case '\177':
        if (lcount) {
            lcount--;
            while (lposition > lpos[lcount]) {
            xputc('\010'); xputc(' '); xputc('\010');
            lposition--;
            }
        }
        break;
    case '\032':
        osflush();
        return (EOF);
    default:
        if (ch == '\t' || (ch >= 0x20 && ch < 0x7F)) {
            lbuf[lcount] = ch;
            lpos[lcount] = lposition;
            if (ch == '\t')
            do {
                xputc(' ');
            } while (++lposition & 7);
            else {
            xputc(ch); lposition++;
            }
            lcount++;
        }
        else {
            osflush();
            switch (ch) {
            case '\003':    xltoplevel();    /* control-c */
            case '\007':    xlcleanup();    /* control-g */
            case '\020':    xlcontinue();    /* control-p */
            case '\032':    return (EOF);    /* control-z */
            default:        return (ch);
            }
        }
    }
}

/* osputc - put a character to the terminal */
osputc(ch,fp)
  int ch; FILE *fp;
{
    /* check for output to something other than stdout */
    if (fp != stdout)
    return (aputc(ch,fp));

    /* check for control characters */
    oscheck();

    /* output the character */
    if (ch == '\n') {
    xputc('\r'); xputc('\n');
    lposition = 0;
    }
    else {
    xputc(ch);
    lposition++;
   }
}

/* oscheck - check for control characters during execution */
oscheck()
{
    int ch;
    if (ch = xcheck())
    switch (ch) {
    case '\002':    osflush(); xlbreak("BREAK",s_unbound); break;
    case '\003':    osflush(); xltoplevel(); break;
    }
}

/* osflush - flush the input line buffer */
osflush()
{
    lindex = lcount = 0;
    osputc('\n',stdout);
    prompt = 1;
}

/* xgetc - get a character from the terminal without echo */
static int xgetc()
{
    return (scr_getc() & 0xFF);
}

/* xputc - put a character to the terminal */
static xputc(ch)
  int ch;
{
    scr_putc(ch);
}

/* xcheck - check for a character */
static int xcheck()
{
    if (scr_poll() == -1)
    return (0);
    return (scr_getc() & 0xFF);
}

/* xdos - execute a dos command */
NODE *xdos(args)
  NODE *args;
{
    char *cmd;
    cmd = xlmatch(STR,&args)->n_str;
    xllastarg(args);
    return (system(cmd) == -1 ? cvfixnum((FIXNUM)errno) : true);
}

/* xgetkey - get a key from the keyboard */
NODE *xgetkey(args)
  NODE *args;
{
    xllastarg(args);
    return (cvfixnum((FIXNUM)scr_getc()));
}

/* xcursor - set the cursor position */
NODE *xcursor(args)
  NODE *args;
{
    int row,col;
    row = xlmatch(INT,&args)->n_int;
    col = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    scr_curs(row,col);
    return (NIL);
}

/* xclear - clear the screen */
NODE *xclear(args)
  NODE *args;
{
    xllastarg(args);
    scr_clear();
    return (NIL);
}

/* xeol - clear to end of line */
NODE *xeol(args)
  NODE *args;
{
    xllastarg(args);
    scr_eol();
    return (NIL);
}


/* xeos - clear to end of screen */
NODE *xeos(args)
  NODE *args;
{
    xllastarg(args);
    scr_eos();
    return (NIL);
}

/* xlinsert - insert line */
NODE *xlinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_linsert();
    return (NIL);
}

/* xldelete - delete line */
NODE *xldelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_ldelete();
    return (NIL);
}

/* xcinsert - insert character */
NODE *xcinsert(args)
  NODE *args;
{
    xllastarg(args);
    scr_cinsert();
    return (NIL);
}

/* xcdelete - delete character */
NODE *xcdelete(args)
  NODE *args;
{
    xllastarg(args);
    scr_cdelete();
    return (NIL);
}

/* xinverse - set/clear inverse video */
NODE *xinverse(args)
  NODE *args;
{
    NODE *val;
    val = xlarg(&args);
    xllastarg(args);
    scr_invers(val ? 1 : 0);
    return (NIL);
}

/* xline - draw a line */
NODE *xline(args)
  NODE *args;
{
    int x1,y1,x2,y2;
    x1 = xlmatch(INT,&args)->n_int;
    y1 = xlmatch(INT,&args)->n_int;
    x2 = xlmatch(INT,&args)->n_int;
    y2 = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    line(x1,y1,x2,y2);
    return (NIL);
}

/* xpoint - draw a point */
NODE *xpoint(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    point(x,y);
    return (NIL);
}

/* xcircle - draw a circle */
NODE *xcircle(args)
  NODE *args;
{
    int x,y,r;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    r = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    circle(x,y,r);
    return (NIL);
}

/* xaspect - set the aspect ratio */
NODE *xaspect(args)
  NODE *args;
{
    int x,y;
    x = xlmatch(INT,&args)->n_int;
    y = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    set_asp(x,y);
    return (NIL);
}

/* xcolors - setup the display colors */
NODE *xcolors(args)
  NODE *args;
{
    int c,p,b;
    c = xlmatch(INT,&args)->n_int;
    p = xlmatch(INT,&args)->n_int;
    b = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    color(c);
    palette(p);
    ground(b);
    return (NIL);
}

/* xmode - set the display mode */
NODE *xmode(args)
  NODE *args;
{
    int m;
    m = xlmatch(INT,&args)->n_int;
    xllastarg(args);
    mode(m);
    return (NIL);
}

/* osfinit - initialize pc specific functions */
osfinit()
{
    xlsubr("DOS",        SUBR,    xdos);
    xlsubr("GET-KEY",        SUBR,    xgetkey);
    xlsubr("SET-CURSOR",    SUBR,    xcursor);
    xlsubr("CLEAR",        SUBR,    xclear);
    xlsubr("CLEAR-EOL",        SUBR,    xeol);
    xlsubr("CLEAR-EOS",        SUBR,    xeos);
    xlsubr("INSERT-LINE",    SUBR,    xlinsert);
    xlsubr("DELETE-LINE",    SUBR,    xldelete);
    xlsubr("INSERT-CHAR",    SUBR,    xcinsert);
    xlsubr("DELETE-CHAR",    SUBR,    xcdelete);
    xlsubr("SET-INVERSE",    SUBR,    xinverse);
    xlsubr("LINE",         SUBR,    xline);
    xlsubr("POINT",        SUBR,    xpoint);
    xlsubr("CIRCLE",        SUBR,    xcircle);
    xlsubr("ASPECT-RATIO",    SUBR,    xaspect);
    xlsubr("COLORS",        SUBR,    xcolors);
    xlsubr("MODE",         SUBR,    xmode);
}


SHAR_EOF
fi # end of overwriting check
if test -f 'readme.1st'
then
    echo shar: will not over-write existing file "'readme.1st'"
else
cat << \SHAR_EOF > 'readme.1st'
XLISP version 1.6
January 6, 1985

README   1ST    This file
XLISP    DOC    XLISP documentation
PCFUN    DOC    PC specific function definitions
XLISPPC  EXE    XLISP executable for IBM-PC compatibles
XLISPMS  EXE    XLISP executable for generic MS-DOS
PCTURTLE LSP    IBM-PC turtle graphics demo program
INIT     LSP    XLISP initialization file
FACT     LSP    Factorial function
FIB      LSP    Fibonacci function
PROLOG   LSP    Tiny Prolog interpreter
PT       LSP    Turtle graphics demo for ANSI terminals
TRACE    LSP    A simple trace facility
PP       LSP    Pretty printer
ART      LSP    Code from my 3/85 Byte article
XLISP    ARC    XLISP source code (archive)
ARC      EXE    File archiver program

To extract the XLISP source files from the XLISP.ARC archive, type the
following command:

    arc e xlisp *.*



SHAR_EOF
fi # end of overwriting check
if test -f 'unixstuff.c'
then
    echo shar: will not over-write existing file "'unixstuff.c'"
else
cat << \SHAR_EOF > 'unixstuff.c'
/* unixstuff.c - unix specific routines */

#include "xlisp.h"

/* external routines */
extern int rand();


/* osinit - initialize */
osinit(banner)
  char *banner;
{
    printf("%s\n",banner);
}

/* osrand - return a random number between 0 and n-1 */
int osrand(n)
  int n;
{
    return((int)(rand()/4294967296.0 * (double)n));
}

/* osgetc - get a character from the terminal */
int osgetc(fp)
  FILE *fp;
{
    return(getc(fp));
}

/* osputc - put a character to the terminal */
osputc(ch,fp)
  int ch; FILE *fp;
{
    putc(ch, fp);
}

/* oscheck - check for control characters during execution */
oscheck()
{
    /* NIX */
}

/* osfinit - initialize pc specific functions */
osfinit()
{
    /* NIX */
}

/* osfinish - cleanup before exit */
osfinish()
{
    /* NIX */
}

SHAR_EOF
fi # end of overwriting check
if test -f 'xlisp.h'
then
    echo shar: will not over-write existing file "'xlisp.h'"
else
cat << \SHAR_EOF > 'xlisp.h'
/* xlisp - a small subset of lisp */
/*    Copyright (c) 1985, by David Michael Betz
    All Rights Reserved
    Permission is granted for unrestricted non-commercial use    */

/* system specific definitions */
/* #define unix */

#include <stdio.h>
#include <ctype.h>
#ifndef MEGAMAX
#include <setjmp.h>
#endif

/* NNODES    number of nodes to allocate in each request (1000) */
/* TDEPTH    trace stack depth (500) */
/* EDEPTH    evaluation stack depth (1000) */
/* FORWARD    type of a forward declaration () */
/* LOCAL    type of a local function (static) */
/* AFMT        printf format for addresses ("%x") */
/* FIXNUM    data type for fixed point numbers (long) */
/* ITYPE    fixed point input conversion routine type (long atol()) */
/* ICNV        fixed point input conversion routine (atol) */
/* IFMT        printf format for fixed point numbers ("%ld") */
/* FLONUM    data type for floating point numbers (float) */
/* SYSTEM    enable the control-d command */

/* absolute value macros */
#ifndef abs
#define abs(n)    ((n) < 0 ? -(n) : (n))
#endif
#ifndef fabs
#define fabs(n)    ((n) < 0.0 ? -(n) : (n))
#endif

/* for the MegaMax compiler */
#ifdef MEGAMAX
#define LOCAL
#define AFMT        "%lx"
#endif

/* for the AZTEC C compiler - small model */
#ifdef AZTEC_SM
#define SYSTEM
#define NIL        0
#endif

/* for the AZTEC C compiler - large model */
#ifdef AZTEC_LM
#define FLONUM        double
#define SYSTEM
#define NIL        0L
#endif

/* for the Lattice C compiler (Amiga) */
#ifdef LATTICE
#undef fabs
#endif

/* default important definitions */
#ifndef NNODES
#define NNODES        1000
#endif
#ifndef TDEPTH
#define TDEPTH        500
#endif
#ifndef EDEPTH
#define EDEPTH        1000
#endif
#ifndef FORWARD
#define FORWARD
#endif
#ifndef LOCAL
#define LOCAL        static
#endif
#ifndef AFMT
#define AFMT        "%x"
#endif
#ifndef FIXNUM
#define FIXNUM        long
#endif
#ifndef ITYPE
#define ITYPE        long atol()
#endif
#ifndef ICNV
#define ICNV(n)        atol(n)
#endif
#ifndef IFMT
#define IFMT        "%ld"
#endif
#ifndef FLONUM
#define FLONUM        float
#endif

/* useful definitions */
#define TRUE    1
#define FALSE    0
#ifndef NIL
#define NIL    (NODE *)0
#endif

/* program limits */
#define STRMAX        100        /* maximum length of a string constant */
#define HSIZE        199        /* symbol hash table size */
#define SAMPLE        100        /* control character sample rate */

/* node types */
#define FREE    0
#define SUBR    1
#define FSUBR    2
#define LIST    3
#define SYM    4
#define INT    5
#define STR    6
#define OBJ    7
#define FPTR    8
#define FLOAT    9
#define VECT    10

/* node flags */
#define MARK    1
#define LEFT    2

/* string types */
#define DYNAMIC    0
#define STATIC    1

/* new node access macros */
#define ntype(x)    ((x)->n_type)

/* type predicates */
#define atom(x)        ((x) == NIL || (x)->n_type != LIST)
#define null(x)        ((x) == NIL)
#define listp(x)    ((x) == NIL || (x)->n_type == LIST)
#define consp(x)    ((x) && (x)->n_type == LIST)
#define subrp(x)    ((x) && (x)->n_type == SUBR)
#define fsubrp(x)    ((x) && (x)->n_type == FSUBR)
#define stringp(x)    ((x) && (x)->n_type == STR)
#define symbolp(x)    ((x) && (x)->n_type == SYM)
#define filep(x)    ((x) && (x)->n_type == FPTR)
#define objectp(x)    ((x) && (x)->n_type == OBJ)
#define fixp(x)        ((x) && (x)->n_type == INT)
#define floatp(x)    ((x) && (x)->n_type == FLOAT)
#define vectorp(x)    ((x) && (x)->n_type == VECT)

/* cons access macros */
#define car(x)        ((x)->n_car)
#define cdr(x)        ((x)->n_cdr)
#define rplaca(x,y)    ((x)->n_car = (y))
#define rplacd(x,y)    ((x)->n_cdr = (y))

/* symbol access macros */
#define getvalue(x)    ((x)->n_symvalue)
#define setvalue(x,v)    ((x)->n_symvalue = (v))
#define getplist(x)    ((x)->n_symplist->n_cdr)
#define setplist(x,v)    ((x)->n_symplist->n_cdr = (v))
#define getpname(x)    ((x)->n_symplist->n_car)

/* vector access macros */
#define getsize(x)    ((x)->n_vsize)
#define getelement(x,i)    ((x)->n_vdata[i])
#define setelement(x,i,v) ((x)->n_vdata[i] = (v))

/* object access macros */
#define getclass(x)    ((x)->n_vdata[0])
#define getivar(x,i)    ((x)->n_vdata[i+1])
#define setivar(x,i,v)    ((x)->n_vdata[i+1] = (v))

/* subr/fsubr access macros */
#define getsubr(x)    ((x)->n_subr)

/* fixnum/flonum access macros */
#define getfixnum(x)    ((x)->n_int)
#define getflonum(x)    ((x)->n_float)

/* string access macros */
#define getstring(x)    ((x)->n_str)
#define setstring(x,v)    ((x)->n_str = (v))

/* file access macros */
#define getfile(x)    ((x)->n_fp)
#define setfile(x,v)    ((x)->n_fp = (v))
#define getsavech(x)    ((x)->n_savech)
#define setsavech(x,v)    ((x)->n_savech = (v))

/* symbol node */
#define n_symplist    n_info.n_xsym.xsy_plist
#define n_symvalue    n_info.n_xsym.xsy_value

/* subr/fsubr node */
#define n_subr        n_info.n_xsubr.xsu_subr

/* list node */
#define n_car        n_info.n_xlist.xl_car
#define n_cdr        n_info.n_xlist.xl_cdr

/* integer node */
#define n_int        n_info.n_xint.xi_int

/* float node */
#define n_float        n_info.n_xfloat.xf_float

/* string node */
#define n_str        n_info.n_xstr.xst_str
#define n_strtype    n_info.n_xstr.xst_type

/* file pointer node */
#define n_fp        n_info.n_xfptr.xf_fp
#define n_savech    n_info.n_xfptr.xf_savech

/* vector/object node */
#define n_vsize        n_info.n_xvect.xv_size
#define n_vdata        n_info.n_xvect.xv_data

/* node structure */
typedef struct node {
    char n_type;        /* type of node */
    char n_flags;        /* flag bits */
    union {            /* value */
    struct xsym {        /* symbol node */
        struct node *xsy_plist;    /* symbol plist - (name . plist) */
        struct node *xsy_value;    /* the current value */
    } n_xsym;
    struct xsubr {        /* subr/fsubr node */
        struct node *(*xsu_subr)();    /* pointer to an internal routine */
    } n_xsubr;
    struct xlist {        /* list node (cons) */
        struct node *xl_car;    /* the car pointer */
        struct node *xl_cdr;    /* the cdr pointer */
    } n_xlist;
    struct xint {        /* integer node */
        FIXNUM xi_int;        /* integer value */
    } n_xint;
    struct xfloat {        /* float node */
        FLONUM xf_float;        /* float value */
    } n_xfloat;
    struct xstr {        /* string node */
        int xst_type;        /* string type */
        char *xst_str;        /* string pointer */
    } n_xstr;
    struct xfptr {        /* file pointer node */
        FILE *xf_fp;        /* the file pointer */
        int xf_savech;        /* lookahead character for input files */
    } n_xfptr;
    struct xvect {        /* vector node */
        int xv_size;        /* vector size */
        struct node **xv_data;    /* vector data */
    } n_xvect;
    } n_info;
} NODE;

/* execution context flags */
#define CF_GO        1
#define CF_RETURN    2
#define CF_THROW    4
#define CF_ERROR    8
#define CF_CLEANUP    16
#define CF_CONTINUE    32
#define CF_TOPLEVEL    64

/* execution context */
typedef struct context {
    int c_flags;            /* context type flags */
    struct node *c_expr;        /* expression (type dependant) */
    jmp_buf c_jmpbuf;            /* longjmp context */
    struct context *c_xlcontext;    /* old value of xlcontext */
    struct node ***c_xlstack;        /* old value of xlstack */
    struct node *c_xlenv;        /* old value of xlenv */
    int c_xltrace;            /* old value of xltrace */
} CONTEXT;

/* function table entry structure */
struct fdef {
    char *f_name;            /* function name */
    int f_type;                /* function type SUBR/FSUBR */
    struct node *(*f_fcn)();        /* function code */
};

/* memory segment structure definition */
struct segment {
    int sg_size;
    struct segment *sg_next;
    struct node sg_nodes[1];
};

/* external procedure declarations */
extern struct node ***xlsave();        /* generate a stack frame */
extern struct node *xleval();        /* evaluate an expression */
extern struct node *xlapply();        /* apply a function to arguments */
extern struct node *xlevlist();        /* evaluate a list of arguments */
extern struct node *xlarg();        /* fetch an argument */
extern struct node *xlevarg();        /* fetch and evaluate an argument */
extern struct node *xlmatch();        /* fetch an typed argument */
extern struct node *xlevmatch();    /* fetch and evaluate a typed arg */
extern struct node *xlgetfile();    /* fetch a file/stream argument */
extern struct node *xlsend();        /* send a message to an object */
extern struct node *xlenter();        /* enter a symbol */
extern struct node *xlsenter();        /* enter a symbol with a static pname */
extern struct node *xlmakesym();    /* make an uninterned symbol */
extern struct node *xlframe();        /* establish a new environment frame */
extern struct node *xlgetvalue();    /* get value of a symbol (checked) */
extern struct node *xlxgetvalue();    /* get value of a symbol */
extern struct node *xlygetvalue();    /* get value of a symbol (no ivars) */

extern struct node *cons();        /* (cons x y) */
extern struct node *consa();        /* (cons x nil) */
extern struct node *consd();        /* (cons nil x) */

extern struct node *cvsymbol();        /* convert a string to a symbol */
extern struct node *cvcsymbol();    /* (same but constant string) */
extern struct node *cvstring();        /* convert a string */
extern struct node *cvcstring();    /* (same but constant string) */
extern struct node *cvfile();        /* convert a FILE * to a file */
extern struct node *cvsubr();        /* convert a function to a subr/fsubr */
extern struct node *cvfixnum();        /* convert a fixnum */
extern struct node *cvflonum();        /* convert a flonum */

extern struct node *newstring();    /* create a new string */
extern struct node *newvector();    /* create a new vector */
extern struct node *newobject();    /* create a new object */

extern struct node *xlgetprop();    /* get the value of a property */
extern char *xlsymname();        /* get the print name of a symbol */

extern void xlsetvalue();
extern void xlprint();
extern void xltest();

SHAR_EOF
fi # end of overwriting check
#    End of shell archive
exit 0